home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / Tools / TWILIGHT / TL_SOURC.E / PASCAL / PAS_BILD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-07-13  |  8.7 KB  |  326 lines
  1. (* Modulentwicklung für Twilight unter Pure Pascal *)
  2. (*       Entwicklung von Carsten Meyer @HH2        *)
  3.  
  4. { Dieses ist das eigentliche Modul,was im Endeffekt als UNIT compiliert }
  5. { wird. - siehe Readme                                                     }
  6.  
  7.  
  8. unit tlm_mod;
  9.  
  10. interface                         { öffentlicher Teil }
  11.  
  12.  
  13. uses tl_inter;
  14.  
  15. type
  16. ParBlk=Record                    { der Parameterblock TYPE für's VDI }
  17.     p_cntrl:^integer;
  18.     p_intin:^integer;
  19.     p_ptsin:^integer;
  20.     p_intout:^integer;
  21.     p_ptsout:^integer;
  22. end;
  23.  
  24. {#############################################################################}
  25.  
  26. { Die Arrays fürs VDI und das Handle }
  27.  
  28. {#############################################################################}
  29.  
  30. var
  31.     contrl:array [0.. 11] of integer;
  32.     intin :array [0..127] of integer;
  33.     intout:array [0..127] of integer;
  34.     ptsin :array [0..127] of integer;
  35.     ptsout:array [0..127] of integer;
  36.     vdi_hnd:integer;
  37.  
  38. {#############################################################################}
  39.  
  40. { der Parameterblock HIMSELF für's VDI }
  41.  
  42. {#############################################################################}
  43.  
  44.  
  45. const VidParBlk:ParBlk
  46. =
  47. (   p_cntrl:@contrl;
  48.     p_intin:@intin;
  49.     p_ptsin:@ptsin;
  50.     p_intout:@intout;
  51.     p_ptsout:@ptsout;
  52. );
  53.  
  54. {#############################################################################}
  55.  
  56. procedure TLM_START(tl_info:INFO_PTR);
  57.  
  58. implementation                        { Nicht öffentlicher Teil }
  59.  
  60. {$S-}                                 { Keine Überprüfung auf Stacküberlauf zur Laufzeit }
  61. {$L-}                                 { Lokale Symbole werden nicht abgelegt }
  62. {$V-}                                  { Strings als Var-Parameter dürfen unterschiedliche Länge haben }
  63. {$D-}                                  { Keine Debuginformation }
  64. {$I-}                                  { Benutzerprogramm prüft auf Fehler bei Ein-/Ausgabe }
  65.  
  66.  
  67. Type
  68.  
  69. GRECT=                                    { Typ eines GRECT's }
  70. record
  71.    x,y,w,h:integer;
  72. end;
  73.  
  74. GRECT_PTR=^GRECT;                        { ein pointer darauf }
  75.           MFDBPtr = ^MFDB;
  76.           MFDB = record
  77.               fd_addr    : Pointer;         { Zeiger auf Speicherblock  }
  78.               fd_w       : Integer;      { Rasterbreite in Pixeln    }
  79.               fd_h       : Integer;      { Rasterhöhe in Pixeln      }
  80.               fd_wdwidth : Integer;      { Rasterbreite in Worten    }
  81.               fd_stand   : Integer;         { 0 geräteabhängiges Format }
  82.                                             { 1 Standardformat          }
  83.               fd_nplanes : Integer;      { Anzahl der Bildebenen     }
  84.               fd_r1      : Integer;      { reserviert                }
  85.               fd_r2      : Integer;       { reserviert                }
  86.               fd_r3      : Integer;       { reserviert                }
  87.           end;
  88.  
  89. {#############################################################################}
  90.  
  91. { ein paar VDI Funktionen }
  92.  
  93. {#############################################################################}
  94.  
  95.  
  96. procedure rect(x1,y1,x2,y2:integer);
  97. begin
  98.     ptsin[0]:=x1;
  99.     ptsin[1]:=y1;
  100.     ptsin[2]:=x2;
  101.     ptsin[3]:=y2;
  102.     contrl[0]:=11;                { GDP          }
  103.     contrl[1]:=2;                { 2 punkte     }
  104.     contrl[2]:=0;                { 0 ptsout    }
  105.     contrl[3]:=0;                { no intin's}
  106.     contrl[4]:=0;                
  107.     contrl[5]:=1;                { v_bar        }
  108.     contrl[6]:=vdi_hnd;
  109.     VDI();
  110. end;
  111.  
  112. procedure line(x1,y1,x2,y2:integer);
  113. begin
  114.     ptsin[0]:=x1;
  115.     ptsin[1]:=y1;
  116.     ptsin[2]:=x2;
  117.     ptsin[3]:=y2;
  118.     contrl[0]:=6;                { v_pline   }
  119.     contrl[1]:=2;                { 2 punkte     }
  120.     contrl[2]:=0;                { 0 ptsout  }
  121.     contrl[3]:=0;                { no intin's}
  122.     contrl[4]:=0;                
  123.     contrl[6]:=vdi_hnd;
  124.     VDI();
  125. end;
  126.  
  127. procedure set_para(para,vdi_func:integer);
  128. begin
  129.     intin[0]:=para;
  130.     contrl[0]:=vdi_func;        { vsl_color  }
  131.     contrl[1]:=0;                { 0 punkte      }
  132.     contrl[2]:=0;                { 0 punkte      }
  133.     contrl[3]:=1;                { 1 intin's     }
  134.     if vdi_func=17 then
  135.         contrl[4]:=1            { color 1 zurück }
  136.     else
  137.         contrl[4]:=0;            { sonst keinen   }
  138.     contrl[6]:=vdi_hnd;
  139.     VDI();
  140. end;
  141.  
  142. procedure wrmode(m:integer);begin set_para(m,32);end;
  143. procedure ltype(l:integer);begin set_para(l,15);end;
  144. procedure lcolor(c:integer);begin set_para(c,17);end;
  145. procedure tcolor(c:integer);begin set_para(c,22);end;
  146. procedure finter(c:integer);begin set_para(c,23);end;
  147. procedure fstyle(c:integer);begin set_para(c,24);end;
  148. procedure fcolor(c:integer);begin set_para(c,25);end;
  149.  
  150. procedure lwidth(    l:integer);     
  151. begin
  152.     ptsin[0]:=l;
  153.     ptsin[1]:=0;
  154.     contrl[0]:=16;                        { vsl_color  } 
  155.     contrl[1]:=1;                        { 1 punkte      }
  156.     contrl[2]:=1;        
  157.     contrl[3]:=0;                        { 1 intin's     }
  158.     contrl[4]:=0;                        { 1 intin's     }
  159.     contrl[6]:=vdi_hnd;
  160.     VDI();
  161. end;
  162.  
  163. procedure lends(    beg,    ende:integer);
  164. begin
  165.     intin[0]:=beg;
  166.     intin[1]:=ende;
  167.     contrl[0]:=108;                        { vsl_color }
  168.     contrl[1]:=0;                        { 1 punkte     }
  169.     contrl[2]:=0;
  170.     contrl[3]:=2;                        { intin's    }
  171.     contrl[4]:=0;                        { 1 intin's    }
  172.     contrl[6]:=vdi_hnd;
  173.     VDI();
  174. end;
  175.  
  176. procedure male_ein_bitblk(x,y:integer; data:pointer;w,h,c:integer);
  177. var scr_mfdb,bit_mfdb:MFDB;
  178. begin
  179.     bit_mfdb.fd_addr:=data;              { Zeiger auf Speicherblock  }
  180.     bit_mfdb.fd_w       :=w;             { Rasterbreite in Pixeln    }
  181.     bit_mfdb.fd_h       :=h;             { Rasterhöhe in Pixeln      }
  182.     bit_mfdb.fd_wdwidth :=(w+15)shr 4;      { Rasterbreite in Worten    }
  183.     bit_mfdb.fd_stand   :=0;                { 0 geräteabhängiges Format }
  184.     bit_mfdb.fd_nplanes :=1;              { Anzahl der Bildebenen     }
  185.  
  186.     scr_mfdb.fd_addr:=NIL;
  187.  
  188.     intin[0]:=2;                            { transparant            }
  189.     intin[1]:=c;                            { vordergrundfarbe       }
  190.     intin[2]:=0;                            { dummy hintergrund      }
  191.  
  192.  
  193.     ptsin[0]:=0;                            { Quell Rechtech im bitblk }
  194.     ptsin[1]:=0;    
  195.     ptsin[2]:=w;
  196.     ptsin[3]:=h;    
  197.     ptsin[4]:=x;                            { Ziel Rechteck im Screen }
  198.     ptsin[5]:=y;
  199.     ptsin[6]:=x+w-1;
  200.     ptsin[7]:=y+h-1;
  201.  
  202.     contrl[ 0]:=121;                                    { VRT_CPYFM  ProfiBuch S.418 }
  203.     contrl[ 1]:=4;                                        { 4 points in }
  204.     contrl[ 2]:=0;                                        { 0 points zurück }
  205.     contrl[ 3]:=3;                                        { 3 ints in }
  206.     contrl[ 4]:=0;                                        { 0 ints zurück }
  207.     contrl[ 6]:=vdi_hnd;
  208.     contrl[ 7]:=integer(longint(@bit_mfdb) shr 16);        { high word der adresse des bit_mfdb }
  209.     contrl[ 8]:=integer(longint(@bit_mfdb) );            { low  word der adresse des bit_mfdb }
  210.     contrl[ 9]:=integer(longint(@scr_mfdb) shr 16);        { high word der adresse des scr_mfdb }
  211.     contrl[10]:=integer(longint(@scr_mfdb) );            { low  word der adresse des scr_mfdb }
  212.  
  213.     VDI();
  214. end;
  215.  
  216. {#############################################################################}
  217.  
  218. { bei Übergabe von NIL clipping AUS, sonst auf das Rechteck, auf das der pointer zeigt AN }
  219.  
  220. {#############################################################################}
  221.  
  222. procedure set_clip(rect: GRECT_PTR);
  223.     begin
  224.             if(rect<>NIL) then
  225.             with rect^ do
  226.         begin
  227.             ptsin[0]:=x;
  228.             ptsin[1]:=y;
  229.             ptsin[2]:=x+w-1;
  230.             ptsin[3]:=y+h-1;
  231.             intin[0]:=1;
  232.         end
  233.     else
  234.         intin[0]:=0;
  235.     contrl[0]:=129;                            { vs_clip           }
  236.     contrl[1]:=2;                            { 0 punkte             }
  237.     contrl[2]:=0;                            { 0 punkte zurück     }
  238.     contrl[3]:=1;                            { 1 intin's            }
  239.     contrl[4]:=0;                            { 0 ints zurück     }
  240.     contrl[6]:=vdi_hnd;
  241.     VDI();
  242. end;
  243.  
  244.  
  245. procedure gtext(x,y:integer; s:string);
  246. var i,l:integer;
  247.     begin
  248.         ptsin[0]:=x;
  249.         ptsin[1]:=y;
  250.         l:=integer(s[0]);
  251.         for i:=0 to l-1 do
  252.             intin[i]:=integer(s[i+1]);
  253.         contrl[0]:=8;
  254.         contrl[1]:=1;
  255.         contrl[3]:=l;
  256.         contrl[6]:=vdi_hnd;
  257.             VDI();
  258. end;
  259.  
  260. procedure itoa(i:integer; var s:string);
  261. var d:integer;
  262.     l:integer;
  263. begin
  264.     s[0]:=char(5);
  265.     s[1]:=char(((i div 10000)mod 10)+ord('0'));
  266.     s[2]:=char(((i div  1000)mod 10)+ord('0'));
  267.     s[3]:=char(((i div   100)mod 10)+ord('0'));
  268.     s[4]:=char(((i div    10)mod 10)+ord('0'));
  269.     s[5]:=char(((i          )mod 10)+ord('0'));
  270. end;
  271.  
  272.  
  273. {#############################################################################}
  274. {                                                                              }
  275. { Hier gehts los....                                                          }
  276. {                                                                              }
  277. {#############################################################################}
  278.  
  279.  
  280. procedure TLM_START(tl_info:INFO_PTR);
  281. var clip:GRECT;
  282.     c,x,y,w,h,dirx,diry:integer;
  283.     bit:BITBLKPTR;
  284.     ttt:string;
  285. begin
  286.     bit:=@rs_bitblk[0];
  287.  
  288.     w:=bit^.bi_wb*8;
  289.     h:=bit^.bi_hl;
  290.     c:=bit^.bi_color;
  291.  
  292.     vdi_hnd:=tl_info^.tl_handle;
  293.     itoa(vdi_hnd,ttt);
  294.     clip.x:=0;
  295.     clip.y:=0;
  296.     clip.w:=tl_info^.max_x+1;
  297.     clip.h:=tl_info^.max_y+1;
  298.     wrmode(1);
  299.     ltype(1);
  300.     lwidth(3);
  301.     lends(1,1); 
  302.     fcolor(0);
  303.     fstyle(1);
  304.     finter(0);
  305.     x:=0;
  306.     y:=0;
  307.     dirx:=13;
  308.     diry:=16;                                    { durch 8 teilbares Iconformat }
  309.     set_clip(@clip);
  310.     repeat
  311.         tcolor(c);
  312.         if c=tl_info^.max_colors then c:=0 else c:=c+1;
  313.         if(dirx>0)and(x+dirx+w>tl_info^.max_x) then dirx:=-dirx;
  314.         if(dirx<0)and(x+dirx<0)                   then dirx:=-dirx;
  315.         if(diry>0)and(y+diry+h>tl_info^.max_y) then diry:=-diry;
  316.         if(diry<0)and(y+diry<0)                   then diry:=-diry;
  317.         x:=x+dirx;
  318.         y:=y+diry;
  319.  
  320.         gtext(x,y,ttt);
  321.  
  322.     until (tl_info^.tl_check()<>0);
  323. end;
  324.  
  325. end.
  326.